00100	C  *****  MUSF4  JUN 15 75 -- WRITES ON MAGTAPE OR DSK.  
00200	C** LOAD WITH MUSIO.REL, MUSIC.REL, (%LTVRLIB for DD display) ****
00300	C   TO WRITE ON DSK: BIGBIT←1; OR RCDFLG←1;    TO WRITE ON TAPE: BIGBIT←-1;
00400	C  BIGBIT←>1; WRITES ON DSK, 4TH LETTER OF NAME IS SET BY NUMBER.
00500	C   IF RCDFLG IS NOT 0 OR 1, ONE LONG FILE IS WRITTEN. PLAY WITH 'PLAY'.
00600		SUBROUTINE SMPLS(LSBUF,ISBCNT,IBOTT,MAXAMP,BIGBIT,RCDFLG)
00700		COMMON JSB(10) /NM/INM(3),MQ(3)
00730	C***	COMMON /NICCOM/ NICNAM
00735	C*** TAKE OUT NICCOM IN MAIN PROG. AND HERE SOMETIME!
00740	CC***	DATA NICNAM /'MUSAA'/
00800		DIMENSION MX(3),IBOTT(1)
00900	      EQUIVALENCE(JSB(3),JSB3),(JSB(4),JSB4),(JSB(5),JSB5),(JSB2,JSB(2))
01000		DATA MX/'AMPL.=0 /      '/,INM(2)/' AMP='/
01200		DATA JSAVE/33000/
01300		IF(J)GO TO 6
01400	86	K=-1
01500	   	IEND=-1
01510		RCX=.001
01600		LNM=0
01700		NUM=0
01710		KR=0
01720		JSC=0
01800		IMAX=50000
01900		IF(BIGBIT.EQ.0)GO TO 8
01905		KBIT=2
01910		KR=BIGBIT
02000		IF(RCDFLG.GT.8000)JSAVE=RCDFLG
02010	C   WILL SAVE AFTER C.33K UNLESS RCDFLG>8K
02100		RCDFLG=0
02200		RCX=.5
02300	CC***87	IF(BIGBIT.LT.0)GO TO 88
02400	CC***	IF(BIGBIT.LT.1)GO TO 8
02500	CC***	JSC=BIGBIT-1.
02600	CC***	LNM='MUSAA'+256*JSC
02700	CC***	BIGBIT=.5
02800	CC***C  NAME CHANGE ONLY WORKS WHEN WRITING ON DSK.
02900	CC***	J=0
03000	CC***	GO TO 87
03100	CC***88	K=0
03300	CC***	KBIT=2
03320		IF(KR.NE.0)J=0
03340		IF(BIGBIT.GT.0)GOTO 88
03350		K=0
03360		RCX=-RCX
03370	88	BIGBIT=RCX
03380		GO TO 9
03500	CC***8	KBIT=3.-BIGBIT
03510	8	KBIT=3
03519		IF(KR.EQ.0)KR=RCDFLG
03520		IF(RCD.NE.RCDFLG)J=0
03523	C FOR ALPHABET SHIFTING
03524		IF(RCDFLG)RCX=-RCX
03525		IF(RCDFLG.NE.-1)RCDFLG=RCDFLG+RCX
03527	C  SO THAT FIRST OF A GROUP MAY BE REPEATED.
03530		RCD=RCDFLG
03560	CC****	IF(KR)KR=0
03600	CC****	IF(RCDFLG.GT.1.)RCDFLG=-1.
03700	9	IF(RCDFLG.GE.0)IBOTT(1024)=0
03800	CC***	JSB(2)=KBIT
03900	C   KBIT=3, 12-BITS.  KBIT=2, 18-BITS. JSB(2) PASSES IT TO CONVRT.
04000		IF(J.EQ.1)GO TO 5
04100	CC****	JNM=NICNAM
04200	CC****	IF(LNM.NE.0)JNM=LNM
04300	CC****1	INM(1)=JNM
04310		IF(KR)KR=-KR
04320		JSC=(KR-1)/26
04330	C  ALPHABET SHIFTING
04340		KR=MOD(KR-1,26)
04350		JNM='MUSAA'+256*JSC
04360	1	INM(1)=JNM+KR*2
04400	CC***	KNM=JNM
04450		KNM='MUSAA'
04500		J=1
04600	5	IF(INM(1).LE.JNM+50)GO TO 2
04700		JNM=JNM+256
04800		IF(JNM.LE.KNM+6400)GO TO 3
04900		KNM=JNM+26112
05000		JNM=KNM
05100	C   RAISES 'MUSZA' TO 'MUTAA'
05200	3	INM(1)=JNM
05300	C NAMES GO FROM 'AAAAA' TO 'AAZZZ' IF KNM='AAAAA': ELSE MUSAA TO MUZZZ.
05400	CX2	IF(K)GO TO 933
05410	2	IF(K)GO TO 33
05500		CALL GETTAP
05600		GO TO 34
05602	CX331	IF(RCDFLG.EQ.-1)INM(1)='MUSIC'
05604	C RCDFLG=-1 TO -.001 'MUSIC' IS THE NAME
05605	CX	CALL PUTMUS(INM(1))
05606	CX	CALL PRTNM
05608	C FILE NAME WILL PRINT TWICE--- BEFORE AND AFTER WRITING.
05609	CX	GO TO 34
05610	CX933	IF(RCDFLG)GO TO 331
05620	C	IF RCDFLG = -1 SET NAME TO 'MUSIC'
05700	33	CALL PUTFIL(INM(1))
05750		CALL PRTNM
05800	34	J=-1
05850		JSC=LSBUF
05875	C  IF RCDFLG←-1; LSBUF=1024 -- OTHERWISE LSBUF=1023 AND LAST WD(1024) IS AMP.
05900		IF(RCDFLG)GO TO 666
06000		JSC=LSBUF+1
06100	C  WRITES LSBUF+1 WDS.  THE '+1' WILL HAVE MAXAMP IN LAST BUFFER.
06200		JSB(1)=JSC
06300		JSB3=INM(1)
06340		JSB2=KBIT
06400		JSB4=9999
06500		JSB5=9998
06600		IF(K)GO TO 66
06700		CALL TOTAPE(JSB(1),128)
06800		GO TO 6
07000	666	IMAX=2050
07100		GO TO 6
07200	66	CALL FASTOU(JSB(1),128)
07300	6	IF(ISBCNT.NE.0)GO TO 7
07400		IF(NUM+LSBUF.LT.JSAVE.OR.RCDFLG)GO TO 4
07500	10	IBOTT(JSC)=MAXAMP
07600		IF(MAXAMP.EQ.0)IBOTT(JSC)=1
07700	C  IF 0, THEN NO WAY TO FIND END OF FILE IN OTHER PROGS.
07800	5444	IEND=0
07900		GO TO 4
08000	7	IF(RCDFLG)GO TO 5444
08100		IBOTT(LSBUF)=(ISBCNT-1)/KBIT       
08200		MAXAMP=-MAXAMP
08300	C  LAST WRD OF LSBUF IS USED FOR WDCNT OF FREE SPACE IN LAST BUFFER.
08400	C  -MAXAMP TELLS CONVRT IT'S THE LAST BUFFER.
08500		GO TO 10
08600	4	NUM=NUM+LSBUF
08700		IF(MAXAMP.EQ.0)CALL MESS(MX)
08900		IF(MAXAMP.LT.IMAX)GO TO 4444
09000	C  IABS(MAXAMP) WON'T WORK 1ST TIME AROUND!!!!!!!⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗
09100	C   49999 IS MAXIMUM AMPL. POSSIBLE (ARBITRARY NUMBER.)
09200		CALL PRTNM
09300		CALL MESS(INM)
09400		CALL PNUM(MAXAMP)
09600		CALL PNUM(MAXAMP)
09700		GO TO 227
09800	4444	IF(K)GO TO 44
09900		 CALL TOTAPE(IBOTT(1),JSC)
10000		GO TO 45
10100	44	CALL FASTOU(IBOTT(1),JSC)
10200	45	IF(IEND)RETURN
10300		IF(RCDFLG)GO TO 224
10400	22	JSB(1)=-1
10450		JSB2=KBIT
10500		JSB3=INM(1)
10600		JSB4=9999
10700		JSB5=9998
10800		IF(K)GO TO 222
10900		CALL TOTAPE(JSB(1),128)
11000	C    '-1' MARKS END OF THIS BATCH OF DATA.
11100	C    '9999' IDENTIFIES IT AS MUSIC DATA WHEN TAPE IS READ.
11200		CALL FINTAP
11300		CALL BACKSP
11400		CALL BACKSP
11500		GO TO 223
11600	224	K=NUM/LSBUF
11700		J=0
11800		NUM=4-K-(K/4*4)
11900	C  MAKES MULTIPLES OF 4K.
12000		J=0
12200	2251	DO 225 K=1,1024
12300	225	IBOTT(K)=0
12400	2261	DO 226 K=1,NUM
12500	226	CALL FASTOU(IBOTT(1),LSBUF)
12600	227	CALL FINFIL
12700		GO TO 2221
12800	222	CALL FASTOU(JSB(1),128)
12900		CALL FINFIL
13000	223	J=1
13100	2231	IF(RCDFLG.GE.0)CALL SAVER
13125	CXXX  TAKE OUT ABOVE FOR EXPORT.
13150		JSB(1)=0
13200	2221	CALL MESS(INM)
13300		CALL PNUM(MAXAMP)
13400		INM(1)=INM(1)+2
13500		RETURN
13600		END
13700	
13710		SUBROUTINE PRTNM
13720		COMMON/NM/INM(3),MQ(3)
13725		DATA MQ(2)/' --  '/
13730		MQ(1)=INM(1)
13740		CALL MESS(MQ)
13750		END
14000	
14010		SUBROUTINE READIN(A,B,C,D,E)
14020	C  THIS IS A DUMMY. WILL BE DEVELOPED LATER.
14030		END
14040	
14100		SUBROUTINE SEG(FUNC)
14200	C  TYPE AMPL, STEP# (UP TO STEP 512). SAME FORMAT AS GEN 1 IN MUSIC5.
14300		DIMENSION FUNC(512),A(4)
14400		COMMON K,STEP,AMP1,AMP2,DIF,IT,IS,ST,STPS,RK
14500		DATA (A(K),K=1,3)/'SEG ARRAY FULL/'/
14800	C   REMOVE ABOVE LATER******** MAYBE.
15000		AMP1=0
15100		ST=0
15200	1	CALL RDNUM(AMP2)
15300		CALL RDNUM(STEP)
15400		IF(STEP.GT.1.)GO TO 3
15500		AMP1=AMP2
15600		GO TO 1
15700	C  STEP=1 AND STEP=0 ARE CONSIDERED THE SAME.
15800	3	DIF=AMP2-AMP1
15900	5	IT=ST
15950		IS=STEP*5.120+.0001
15975		STEP=IS
16000	 	STPS=STEP-ST
16100		IS=STPS
16150		IF(IS+IT.GT.512)GO TO 6
16200		ST=STEP
16300		IF(ST.EQ.0)STEP=1.
16400		DO 2 K=1,IS
16600		RK=K
16700	2	FUNC(K+IT)=AMP1+DIF*RK/STPS
16800		AMP1=AMP2
16900	      	ST=STEP
17100		IF(STEP.LT.512)GO TO 1
17300	1102	CALL MESS(A)
17350		IF(NOTDD(K))CALL SEE(FUNC)
17355	C  'NOTDD' CHECKS TO SEE IF ITS A DATADISC DPY.
17400		RETURN
17500	6	K=1
17550	C  NEXT TO READ IN FULL ARRAYS
17600	8	CALL RDNUM(RK)
17700	7	FUNC(K)=RK
17800		K=K+1
17900		IF(K.LE.512)GO TO 8
18000		GO TO 1102
18100		END
18200	
18300		SUBROUTINE SYNTH (FUNC)
18400	C    AFTER 'SYNTH(F1);'  TYPE 99= TO USE  H,A,P,K: OTHERWISE
18500	C    H,A ONLY.  TYPE 999 TO END. NORMALIZATION IS AUTOMATIC.
18600		DIMENSION FUNC(512),F(5)
18700		COMMON I,XX,X,H,K,CON,XK,FAC,AMP,Y
18800		DATA (F(I),I=1,4)/'SYNTH ARRAY FULL/'/
18900		DO 15 I=1,512
19000	15	FUNC(I)=0.0
19100	 	CALL RDNUM(XX)
19200		IF(XX.EQ.99)XX=-99
19300		FAC=360./512.
19400		H=XX
19500		IF(XX)CALL RDNUM(H)
19600	16	CALL RDNUM(AMP)
19700		IF(XX)GO TO 1016
19800		X=0
19900		CON=0
20000		GO TO 2016
20100	1016	CALL RDNUM(X)
20200		X=X*512./360.+1.0
20300		CALL RDNUM(CON)
20400	2016	DO 17 J=1,512
20500		XK=SIND(X*FAC)*AMP+CON
20600		IF(CON.LT.100.0)GO TO 1
20700		FUNC(J)=(XK-100.)*FUNC(J)
20800		GO TO 2
20900	1	FUNC(J)=FUNC(J)+XK
21000	2	X=X+H
21100		IF(X.LE.512.)GO TO 17
21200		X=X-512.
21300	17	CONTINUE
21400		CALL RDNUM(H)
21500		IF(H.NE.999.)GO TO 16
21600	2200	X=FUNC(1)
21700		DO 19 I=2,512
21800		H=ABS(FUNC(I))
21900	19	IF(X.LT.H)X=H
22000		DO 20 I=1,512
22100	20	FUNC(I)=FUNC(I)/X
22200		CALL MESS(F)
22300		IF(NOTDD(K))CALL SEE(FUNC)
22400		END
22500	C   ***********  DUR2 1969  *********
22550	C*TAKE OUT DUR AND SEE FOR EXPORT**SEE SCORE.MAN FOR USE OF DUR2(X,Y,Z)
22562	
22600		FUNCTION DUR(P2,SPEED,CHNS)
22700		COMMON P,ISR,NC,IDUR,ID,IP(5)
22800		DATA IP/20000,25000,10000,50000,100000/
22900		P=P2
23000		ISPD=SPEED
23100		NC=CHNS*30+.3
23200	3	IDUR=P*10000+.5
23300	5	IDUR=(IDUR*IP(ISPD))/1000
23400	6	ID=IDUR/NC
23500	7	ID=IDUR-ID*NC
23600		IF(ID.EQ.0)GO TO 1
23700		P=P+.0001
23800		GO TO 3
23900	1	DUR=P
24000		RETURN
24100		END
24200	
24300	
24400		SUBROUTINE SEE(FUNC)
24500	
24600	CC	DIMENSION FUNC(512),SU(150),C(3)
24610		DIMENSION FUNC(512),SU(150)
24700	CC	DATA (C(I),I=1,2)/'0=CLEAR: '/
24800		CALL DDCLR
24900	C  THIS VERSION MUST BE LOADED WITH %LTVRLIB (FOR 'DDCLR')
25000		CALL TYPLOC(-100,-512)
25100		CALL DPYSET(2,SU,150)
25200	CC	CALL DPYBRT(6)
25300		CALL ALINE(-264,200,256,200)
25400		CALL ALINE(-256,-56,-256,456)
25500	CC	CALL AIVECT(0,200)
25600	1	IY=FUNC(1)*256.0+200.0
25700		CALL AIVECT(-256,IY)
25800		DO 14 I=2,512,3
25900		IY2=FUNC(I)*256.0+200.0
26000		CALL RVECT(3,IY2-IY)
26100	14	IY=IY2
26200		CALL DPYOUT(2)
26300	CC100	CALL MESS(C)
26400	CC1100   	CALL RDNUM(X)
26500	CC	CALL DPYCLR
26700		END